home *** CD-ROM | disk | FTP | other *** search
/ The Best of MacTutor - S…e Code for Volumes 1 to 5 / The Best of MacTutor - Source Code for Volume 1-5 (Wayzata Technology)(6031)(1990).bin / Source Code / #27 (Dec 87) / Forth Hypercard cmd / XCMD defs.edit next >
Text File  |  1987-11-13  |  9KB  |  289 lines
  1. ( *** Hypercard external commands. J.L. October 1987 *** )
  2.  
  3. ONLY FORTH ALSO ASSEMBLER ALSO MAC
  4.  
  5. 4ascii XFCN CONSTANT "xfcn
  6. 4ascii XCMD CONSTANT "xcmd
  7.  
  8. $9DE CONSTANT WMgrPort
  9.  
  10. \ structure of a Hypercard parameter block    
  11.  
  12. 0  CONSTANT paramCount        \ INTEGER; the number of arguments
  13. 2  CONSTANT params        \ ARRAY[1..16] OF Handle; the arguments
  14. 66 CONSTANT returnValue        \ Handle; the result of this XCMD
  15. 70 CONSTANT passFlag        \ BOOLEAN; pass the message on?
  16. 72 CONSTANT entryPoint        \ ProcPtr; call back to HyperCard
  17. 76 CONSTANT request        \ INTEGER; what you want to do
  18. 78 CONSTANT result        \ INTEGER; the answer it gives
  19. 80 CONSTANT inArgs        \ ARRAY[1..8] OF LongInt;
  20.                 \ args XCMD sends HyperCard
  21. 112 CONSTANT outArgs        \ ARRAY[1..4] OF LongInt;
  22.                 \ answer HyperCard sends back
  23. \ result codes
  24. 0 CONSTANT xresSucc
  25. 1 CONSTANT xresFail
  26. 2 CONSTANT xresNotImp
  27.   
  28. \ request codes
  29. 1 CONSTANT  xreqSendCardMessage
  30. 2 CONSTANT  xreqEvalExpr
  31. 3 CONSTANT  xreqStringLength
  32. 4 CONSTANT  xreqStringMatch
  33. 5 CONSTANT  xreqSendHCMessage
  34. 6 CONSTANT  xreqZeroBytes    
  35. 7 CONSTANT  xreqPasToZero
  36. 8 CONSTANT  xreqZeroToPas
  37. 9 CONSTANT  xreqStrToLong
  38. 10 CONSTANT xreqStrToNum
  39. 11 CONSTANT xreqStrToBool
  40. 12 CONSTANT xreqStrToExt
  41. 13 CONSTANT xreqLongToStr
  42. 14 CONSTANT xreqNumToStr
  43. 15 CONSTANT xreqNumToHex
  44. 16 CONSTANT xreqBoolToStr
  45. 17 CONSTANT xreqExtToStr
  46. 18 CONSTANT xreqGetGlobal
  47. 19 CONSTANT xreqSetGlobal
  48. 20 CONSTANT xreqGetFieldByName
  49. 21 CONSTANT xreqGetFieldByNum
  50. 22 CONSTANT xreqGetFieldByID
  51. 23 CONSTANT xreqSetFieldByName
  52. 24 CONSTANT xreqSetFieldByNum
  53. 25 CONSTANT xreqSetFieldByID
  54. 26 CONSTANT xreqStringEqual
  55. 27 CONSTANT xreqReturnToPas
  56. 28 CONSTANT xreqScanToReturn
  57. 39 CONSTANT xreqScanToZero \ was supposed to be 29. Oops!
  58.  
  59. ( **** Pascal definitions for the callable Hypercard routines follow:
  60.   
  61. PROCEDURE SendCardMessage(msg: Str255);
  62. {  Send a HyperCard message (a command with arguments) to the current card. }
  63.  
  64. FUNCTION EvalExpr(expr: Str255): Handle;
  65. {  Evaluate a HyperCard expression and return the answer.  The answer is
  66.    a handle to a zero-terminated string. }
  67.  
  68. FUNCTION StringLength(strPtr: Ptr): LongInt;
  69. {  Count the characters from where strPtr points until the next zero byte. 
  70.    Does not count the zero itself.  strPtr must be a zero-terminated string.  }
  71.  
  72. FUNCTION StringMatch(pattern: Str255; target: Ptr): Ptr;
  73. { Perform case-insensitive match looking for pattern anywhere in
  74.   target, returning a pointer to first character of the first match,
  75.   in target or NIL if no match found.  pattern is a Pascal string,
  76.   and target is a zero-terminated string. }
  77.  
  78. PROCEDURE ZeroBytes(dstPtr: Ptr; longCount: LongInt);
  79. {  Write zeros into memory starting at destPtr and going for longCount 
  80.    number of bytes. }
  81.  
  82. FUNCTION PasToZero(str: Str255): Handle;
  83. {  Convert a Pascal string to a zero-terminated string.  Returns a handle
  84.    to a new zero-terminated string.  The caller must dispose the handle.
  85.    You'll need to do this for any result or argument you send from 
  86.    your XCMD to HyperTalk. }
  87.  
  88. PROCEDURE ZeroToPas(zeroStr: Ptr; VAR pasStr: Str255);
  89. {  Fill the Pascal string with the contents of the zero-terminated
  90.    string.  You create the Pascal string and pass it in as a VAR 
  91.    parameter.  Useful for converting the arguments of any XCMD to 
  92.    Pascal strings.}
  93.  
  94. FUNCTION StrToLong(str: Str31): LongInt;
  95. {  Convert a string of ASCII decimal digits to an unsigned long integer. }
  96.  
  97. FUNCTION StrToNum(str: Str31): LongInt;
  98. {  Convert a string of ASCII decimal digits to a signed long integer.
  99.    Negative sign is allowed.  }
  100.  
  101. FUNCTION StrToBool(str: Str31): BOOLEAN;
  102. {  Convert the Pascal strings 'true' and 'false' to booleans. }
  103.  
  104. FUNCTION StrToExt(str: Str31): Extended;
  105. {  Convert a string of ASCII decimal digits to an extended long integer. }
  106. VAR x: Extended;
  107.  
  108. FUNCTION LongToStr(posNum: LongInt): Str31;
  109. {  Convert an unsigned long integer to a Pascal string.  }
  110.  
  111. FUNCTION NumToStr(num: LongInt): Str31;
  112. {  Convert a signed long integer to a Pascal string.  }
  113.  
  114. FUNCTION NumToHex(num: LongInt; nDigits: INTEGER): Str31;
  115. {  Convert an unsigned long integer to a hexadecimal number and put it
  116.    into a Pascal string.  }
  117.  
  118. FUNCTION BoolToStr(bool: BOOLEAN): Str31;
  119. {  Convert a boolean to 'true' or 'false'.  }
  120. VAR str: Str31;
  121.  
  122. FUNCTION ExtToStr(num: Extended): Str31;
  123. {  Convert an extended long integer to decimal digits in a string.  }
  124.  
  125. FUNCTION GetGlobal(globName: Str255): Handle;
  126. {  Return a handle to a zero-terminated string containing the value of 
  127.    the specified HyperTalk global variable.  }
  128.  
  129. PROCEDURE SetGlobal(globName: Str255; globValue: Handle);
  130. {  Set the value of the specified HyperTalk global variable to be
  131.    the zero-terminated string in globValue.  The contents of the 
  132.    Handle are copied, so you must still dispose it afterwards.  }
  133.  
  134. FUNCTION GetFieldByName(cardFieldFlag: BOOLEAN; fieldName: Str255): Handle;
  135. {  Return a handle to a zero-terminated string containing the value of 
  136.    field fieldName on the current card.  You must dispose the handle.  }
  137.  
  138. FUNCTION GetFieldByNum(cardFieldFlag: BOOLEAN; fieldNum: INTEGER): Handle;
  139. {  Return a handle to a zero-terminated string containing the value of 
  140.    field fieldNum on the current card.  You must dispose the handle.  }
  141.  
  142. FUNCTION GetFieldByID(cardFieldFlag: BOOLEAN; fieldID: INTEGER): Handle;
  143. {  Return a handle to a zero-terminated string containing the value of 
  144.    the field whise ID is fieldID.  You must dispose the handle.  }
  145.  
  146. PROCEDURE SetFieldByName(cardFieldFlag: BOOLEAN; fieldName: Str255; fieldVal: Handle);
  147. {  Set the value of field fieldName to be the zero-terminated string 
  148.    in fieldVal.  The contents of the Handle are copied, so you must 
  149.    still dispose it afterwards.  }
  150.  
  151. PROCEDURE SetFieldByNum(cardFieldFlag: BOOLEAN; fieldNum: INTEGER; fieldVal: Handle);
  152. {  Set the value of field fieldNum to be the zero-terminated string 
  153.    in fieldVal.  The contents of the Handle are copied, so you must 
  154.    still dispose it afterwards.  }
  155.  
  156. PROCEDURE SetFieldByID(cardFieldFlag: BOOLEAN; fieldID: INTEGER; fieldVal: Handle);
  157. {  Set the value of the field whose ID is fieldID to be the zero-
  158.    terminated string in fieldVal.  The contents of the Handle are 
  159.    copied, so you must still dispose it afterwards.  }
  160.  
  161. FUNCTION StringEqual(str1,str2: Str255): BOOLEAN;
  162. {  Return true if the two strings have the same characters.  
  163.    Case insensitive compare of the strings.  }
  164.  
  165. PROCEDURE ReturnToPas(zeroStr: Ptr; VAR pasStr: Str255);
  166. {  zeroStr points into a zero-terminated string.  Collect the 
  167.    characters from there to the next carriage Return and return 
  168.    them in the Pascal string pasStr.  If a Return is not found, 
  169.    collect chars until the end of the string. }
  170.  
  171. PROCEDURE ScanToReturn(VAR scanPtr: Ptr);
  172. {  Move the pointer scanPtr along a zero-terminated 
  173.    string until it points at a Return character
  174.    or a zero byte.  }
  175.  
  176. PROCEDURE ScanToZero(VAR scanPtr: Ptr);
  177. {  Move the pointer scanPtr along a zero-terminated 
  178.    string until it points at a zero byte.  }
  179.  
  180. **** End of Pascal definitions )
  181.  
  182. \ **** Hypercard glue macros
  183.  
  184. CODE HC.prelude
  185.     LINK    A6,#-512             ( 512 bytes of local Forth stack )
  186.     MOVEM.L A0-A5/D0-D7,-(A7)        ( save registers )
  187.     MOVE.L A6,A3                ( setup local loop return stack )
  188.     SUBA.L #256,A3                ( in the low 256 local stack bytes )
  189.     MOVE.L 8(A6),D0             ( pointer to parameter block )
  190.     MOVE.L D0,-(A6)
  191.     RTS            \ just to indicate the MACHro stops here 
  192. END-CODE MACH
  193.  
  194. CODE HC.epilogue
  195.     MOVEM.L (A7)+,A0-A5/D0-D7    ( restore registers )
  196.     UNLK    A6
  197.     MOVE.L    (A7)+,A0            ( return address )
  198.     ADD.W    #4,A7                ( pop off 4 bytes of parameters )
  199.     JMP        (A0)
  200.     RTS
  201. END-CODE MACH
  202.  
  203. ( ------------------- )
  204.  
  205. header flashy.start
  206.     JMP flashy.start  ( to be filled later )
  207.  
  208. header doneString 
  209.     DC.B 'Done'
  210.     DC.B 0
  211.  
  212. header errorString 
  213.     DC.B 'Error'
  214.     DC.B 0
  215.  
  216. header PascalString 255 allot
  217.  
  218. CODE callJSR
  219.     MOVE.L (A6)+,-(A7)
  220.     RTS
  221. END-CODE
  222.  
  223. : ZeroToPas    { HCPars CStr PStr | -- }
  224.     CStr HCPars inArgs + !
  225.     PStr HCPars inArgs + 4 + !
  226.     xreqZeroToPas HCPars request + w!
  227.     HCPars entryPoint + @ callJSR ( call Hypercard here )
  228. ;
  229.     
  230. : StrToNum     { HCPars Str | -- result }
  231.     Str HCPars inArgs + !
  232.     xreqStrToNum HCPars request + w!
  233.     HCPars entryPoint + @ callJSR 
  234.     HCPars outArgs + @
  235. ;     
  236.  
  237. : flashy    { HCpars | hP1 screen times -- }
  238.     HCPars params + @ -> hP1
  239.     hP1 (call) HLock drop    \ yes, I know I'm paranoid about this
  240.     HCPars hP1 @ ['] PascalString ZeroToPas
  241.     hP1 (call) HUnLock drop
  242.     HCPars ['] PascalString StrToNum -> times
  243.     times 0> IF
  244.       WMgrPort @ -> screen
  245.       times 0 DO
  246.         screen portRect + dup 
  247.         (call) InvertRect (call) InvertRect
  248.         LOOP 
  249.       ['] doneString 5 (call) PtrToHand drop
  250.         HCpars returnValue + !
  251.     ELSE
  252.       ['] errorString 6 (call) PtrToHand drop
  253.         HCpars returnValue + !
  254.     THEN
  255. ;
  256.  
  257. : flashy.glue
  258.     HC.prelude  flashy  HC.epilogue  ;
  259.  
  260. header flashy.end
  261.  
  262. ' flashy.glue ' flashy.start 2+ - ' flashy.start 2+ w!
  263.  
  264.  
  265. ( *** making the XCMD resource *** )
  266. : $create-res call CreateResFile call ResError L_ext ;
  267.  
  268. : $open-res { addr | refNum -- result }
  269.     addr call openresfile -> refNum
  270.     call ResError L_ext
  271.     dup not IF drop refNum THEN 
  272. ;
  273.  
  274. : $close-res call CloseResFile call ResError L_ext ;
  275.  
  276. : make-xcmd { | refNum -- }
  277.     " xcmd.res" dup $create-res
  278.     abort" You have to delete the old 'xcmd.res' file first."
  279.     $open-res dup -> refNum call UseResFile 
  280.     ['] flashy.start ['] flashy.end over - 
  281.         call PtrToHand drop ( result code )
  282.         "xcmd 2000 " flashy" call AddResource
  283.     refNum $close-res drop ( result code )
  284. ;
  285.  
  286.      
  287.  
  288.  
  289.